perm filename TR2.F4[P11,LCS] blob
sn#341678 filedate 1978-03-12 generic text, type C, neo UTF8
COMMENT ā VALID 00002 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 C THIS ROUTINE FINDS KEY WORDS IN I ARRAY AND PUTS THEIR KEY NUMS
C00015 ENDMK
Cā;
C THIS ROUTINE FINDS KEY WORDS IN I ARRAY AND PUTS THEIR KEY NUMS
C INTO THE IX ARRAY. IX ARRAY ADVANCES 2 WORDS AT A TIME.
C IF 2ND WRD OF EACH PAIR IS NON-ZERO THEN 1ST IS FLT. PT. NUM.
C KCNT IS WORD COUNT OF INPUT STRING.
SUBROUTINE MPACK(KCNT, I,IX,IPTR)
COMMON/IGEN/IGEN
COMMON /TR/Q(80),QX(100),NN(2),LX(12),INST(27,5),MX5(40)
DIMENSION I(1)
IX=I(1)
DO 100 K=1,12
IF(IX.NE.LX(K))GO TO 100
C LOOK FOR PUNCTUATION, ARITHMETIC OPERATORS, ETC.
RETURN
100 CONTINUE
101 N=I(2)
L=I(3)
IF(IGEN.NE.2)GO TO 1000
C IGEN=2=READING INSTRUMENT DEFINITION
CODE NUMS ARE 1-13 FOR UNIT GENS., 100+ FOR B, 200+ FOR P, 300+ FOR F.
C ORD. OF UNIT GENS:OUT,OSC,AD2,RAN,ENV,STR,AD3,AD4,MLT,SET,RAH,END,INS
IF(IX.EQ.'P')GO TO 14
IF(IX.EQ.'F')GO TO 15
IF(IX.EQ.'B')GO TO 16
IF(IX.EQ.'A')GO TO 1
IF(IX.EQ.'O')GO TO 2
IF(IX.EQ.'R')GO TO 3
IF(IX.EQ.'E')GO TO 4
IF(IX.EQ.'S')GO TO 5
IF(IX.EQ.'M')GO TO 17
IF(IX.EQ.'I')GO TO 33
C IF NOT A KNOWN WORD THEN ERROR
999 CALL ERR(5)
C NEXT FOR 'MLT'
17 IF(N.NE.'L')GO TO 999
IF(L.NE.'T')GO TO 999
IX=9
RETURN
1 IF(N.NE.'D')GO TO 999
IF(L.EQ.'2')GO TO 6
C 'AD2, AD3, AD4'
IF(L.EQ.'3')GO TO 7
IF(L.NE.'4')GO TO 999
IX=8
RETURN
6 IX=3
RETURN
7 IX=7
RETURN
2 IF(N.EQ.'S')GO TO 10
IF(N.NE.'U')GO TO 999
IF(L.NE.'T')GO TO 999
C 'OUT'
IX=1
RETURN
10 IF(L.NE.'C')GO TO 999
C 'OSC'
IX=2
RETURN
3 IF(N.NE.'A')GO TO 999
IF(L.EQ.'N')GO TO 11
IF(L.NE.'H')GO TO 999
C 'RAN', 'RAH'
IX=11
RETURN
11 IX=4
RETURN
4 IF(N.NE.'N')GO TO 999
IF(L.EQ.'V')GO TO 12
C ENV, END
IF(L.NE.'D')GO TO 999
IX=12
RETURN
12 IX=5
RETURN
5 IF(N.EQ.'T')GO TO 13
IF(N.NE.'E')GO TO 999
C SET, STR
IF(L.NE.'T')GO TO 999
IX=10
RETURN
13 IF(L.NE.'R')GO TO 999
IX=6
RETURN
14 J=200
C PN
18 IF(N.LT.'0'.OR.N.GT.'9')GO TO 999
K2=0
K1=NASCI(N)
C!**** CHANGE ASCII INTO NUMBER
IF(KCNT.EQ.2)GO TO 19
C ARE THERE 2 DIGITS AFTER P, F OR B?
IF(L.LT.'0'.OR.L.GT.'9')GO TO 999
K1=K1*10
K2=NASCI(L)
19 IX=J+K1+K2
RETURN
15 J=300
C FN
GO TO 18
16 J=100
C BN
GO TO 18
C NEXT FOR OTHER (MUS10 TYPE) KEY WORDS.
1000 IF(KCNT.LE.3)GO TO 2000
C JUMP TO FIND NOTE NAMES, PARAMS, FUNCTS.
LN=I(4)
IF(IX.EQ.'P')GO TO 20
C THIS LIST BEGINS WITH CODE NUM. 400:
C PLAY,FINI,SRATE,NCHNS,PRINT,CHA,POWER,SRT,GEN,DUR,FREQ,INSTRU,UNIT GEN.
IF(IX.EQ.'F')GO TO 21
IF(IX.EQ.'S')GO TO 22
IF(IX.EQ.'N')GO TO 23
IF(IX.EQ.'I')GO TO 27
IF(IX.NE.'U')GO TO 28
C JUMP IF NOT ONE OF THE SPECIAL WORDS. IT MAY BE AN INSTR.
C****** INSTRS CANNOT HAVE SAME NAME(1ST 4 LTRS) AS ANY OF THESE WORDS*******
IF(N.NE.'N')GO TO 28
IF(L.NE.'I')GO TO 28
IF(LN.NE.'T')GO TO 28
C UNIT GEN (FOR SPECIAL DEFINITIONS)
IX=413
RETURN
20 IF(N.NE.'L')GO TO 30
IF(L.NE.'A')GO TO 28
IF(LN.NE.'Y')GO TO 28
C PLAY
IX=400
RETURN
30 IF(N.NE.'R')GO TO 31
IF(L.NE.'I')GO TO 28
IF(LN.NE.'N')GO TO 28
C PRINT
IX=404
RETURN
31 IF(N.NE.'O')GO TO 28
IF(L.NE.'W')GO TO 28
IF(LN.NE.'E')GO TO 28
C POWER(X,Y)
IX=406
RETURN
21 IF(N.NE.'I')GO TO 32
IF(L.NE.'N')GO TO 28
IF(LN.NE.'I')GO TO 28
C UNIT GEN (FOR SPECIAL DEFINITIONS)
IX=401
RETURN
22 IF(N.NE.'R')GO TO 28
IF(L.EQ.'T'.AND.KCNT.EQ.3)GO TO 222
IF(L.NE.'A')GO TO 29
IF(LN.NE.'T')GO TO 28
C SRATE, SRT
222 IX=402
RETURN
29 IF(L.NE.'T')GO TO 28
IX=407
RETURN
23 IF(N.NE.'C')GO TO 28
IF(L.NE.'H')GO TO 28
IF(LN.NE.'N')GO TO 28
C NCHNS
IX=403
RETURN
24 IF(N.NE.'H')GO TO 28
IF(L.NE.'A')GO TO 28
C CHA
IX=405
RETURN
25 IF(N.NE.'E')GO TO 28
IF(L.NE.'N')GO TO 28
C GEN
IX=409
RETURN
26 IF(N.NE.'U')GO TO 28
IF(L.NE.'R')GO TO 28
C DUR
IX=410
RETURN
27 IF(N.NE.'N')GO TO 28
IF(L.NE.'S')GO TO 28
IF(KCNT.EQ.3)GO TO 33
IF(LN.NE.'T')GO TO 28
IF(I(5).NE.'R')GO TO 28
IF(I(6).NE.'U')GO TO 28
C INSTRUMENT
IX=412
RETURN
33 IX=13
C 'INS'
RETURN
32 IF(N.NE.'R')GO TO 28
IF(L.NE.'E')GO TO 28
IF(LN.NE.'Q')GO TO 28
C FREQ
IX=411
RETURN
28 IX=-IPTR
C SEND BACK NEG. POINTER TO I ARRAY SO IT WILL LOOK FOR INST. NAME.
RETURN
2000 IF(IX.EQ.'P')GO TO 14
C FINDS (P1, P21, ETC.)
IF(IX.EQ.'S')GO TO 22
C 'SRT'
IF(IX.NE.'F')GO TO 34
C A FUNC??
IF(N.GE.'0'.AND.N.LE.'9')GO TO 15
IF(KCNT.EQ.3)GO TO 28
IX=510
GO TO 36
34 IF(IX.NE.'C')GO TO 35
IF(KCNT.EQ.3)GO TO 24
C JUMP IF NOT A NOTE
IX=501
C AT THIS POINT NOTE NUMBERS RUN FROM 500 TO 520 (CF TO BS)
GO TO 36
35 IF(IX.NE.'G')GO TO 38
C NOW A 'GEN' OR A NOTE
IF(KCNT.EQ.3)GO TO 25
IX=513
C THE NOTE 'G'
36 IF(KCNT.EQ.1)RETURN
IF(N.EQ.'F')GO TO 39
IF(N.NE.'S') GO TO 28
C NOW IT'S NOT A NOTE
40 IX=IX+1
C SHARP
RETURN
39 IX=IX-1
C FLAT
RETURN
38 IF(IX.NE.'D')GO TO 41
IF(KCNT.EQ.3)GO TO 26
C GO LOOK FOR 'DUR'
IX=504
GO TO 36
41 IF(IX.EQ.'I')GO TO 27
C CATCHES 'INS'
IF(IX.NE.'E')GO TO 42
IF(KCNT.EQ.3)GO TO 4
C 'END' OR NOTE 'E'?
IX=507
GO TO 36
42 IF(KCNT.EQ.3)GO TO 28
IF(IX.NE.'A')GO TO 43
IX=516
GO TO 36
43 IF(IX.NE.'B')GO TO 28
IX=519
GO TO 36
END
CC SUBROUTINE MPACK(WDCNT, I,NM)
CC EQUIVALENCE (NMM,NX)
CC DIMENSION I(1),M(10),NX(2)
CC DOUBLE PRECISION NM,NMM
CC INTEGER WDCNT
CC DATA KK/128/,LL/"377777777777/,JJ/"2000000000/
CC DATA MM/"774000000000/
CC DO 1 K=1,10
CC M(K)=I(K)
CC1 IF(K.GT.WDCNT)M(K)=' '
CC JX=0
CC DO 2 J=1,2
CC NN=0
CC DO 10 K=5,1,-1
CC NN=NN .OR. (M(K+JX) .AND. MM)
CC IF (K-1) 20,20,17
CC17 IF (NN.GE.0)GO TO 13
CC NN = (( NN .AND. LL)/KK) .OR. JJ
CC GO TO 10
CC13 NN = NN / KK
CC10 CONTINUE
CC20 JX=5
CC2 NX(J)=NN
CC NM=NMM
CC END
SUBROUTINE ERR(N)
GO TO (1,2,3,4,5)N
1 TYPE 101
STOP
101 FORMAT(' MISSING SEMICOLON')
2 TYPE 102
STOP
102 FORMAT(' MISSING PARENTHESIS')
3 TYPE 103
STOP
103 FORMAT(' MISSING COMMA')
4 TYPE 104
104 FORMAT(' MISSING PLAY;')
5 TYPE 105
105 FORMAT(' UNKNOWN WORD')
STOP
END
SUBROUTINE ARITH(Y,W,LL)
DIMENSION W(1)
COMMON /AR/IOP
47 X=W(LL-1)
GO TO (41,42,43,44),IOP
41 X=X*Y
GO TO 45
42 X=X/Y
GO TO 45
43 X=X-Y
GO TO 45
44 X=X+Y
45 W(LL-1)=X
END